open Fr
open FrGui_common

(* small bug: while button is held, GDK will report leave_notify
   but will still continue to produce motion_notify afterward
   and will report leave_notify again when button is released
   this causes a glitch when leaving window with button held down *)
let lift_pointer ~p2c widget event =
	let force () = None
	and start c =
		event#add [ `POINTER_MOTION; `ENTER_NOTIFY; `LEAVE_NOTIFY ];
		[event#connect#motion_notify ~callback: (fun e ->
			set_cell c (Some (p2c (GdkEvent.Motion.x e, GdkEvent.Motion.y e)));
			false);
		 event#connect#enter_notify ~callback: (fun e ->
			set_cell c (Some (p2c (GdkEvent.Crossing.x e, GdkEvent.Crossing.y e)));
			false);
		 event#connect#leave_notify ~callback: (fun e ->
			set_cell c None; false)]
	and stop hl =
		List.iter (GtkSignal.disconnect widget#as_widget) hl in
	behavior_source force start stop

type button = [ `Left | `Middle | `Right | `Button of int ]
let button_gtk = function
	| 1 -> `Left
	| 2 -> `Middle
	| 3 -> `Right
	| n -> `Button n

let lift_buttons event =
	(* we don't need enter_notify/leave_notify because
	   GTK doesn't send these until no buttons are pressed *)
	event#add [ `BUTTON_PRESS; `BUTTON_RELEASE ];
	accum_b []
		(merge_e [
			(on (lift_event false event#connect#button_press) e l ->
				if GdkEvent.get_type e <> `BUTTON_PRESS then l
				else let button = button_gtk (GdkEvent.Button.button e) in
				if List.mem button l then l
				else button :: l);
			(on (lift_event false event#connect#button_release) e l ->
				let button = button_gtk (GdkEvent.Button.button e) in
				List.filter (fun b -> b <> button) l);
		])

let lift_click event =
	event#add [ `BUTTON_PRESS ];
	let button_press =
		filter_e
			(fun e -> GdkEvent.get_type e = `BUTTON_PRESS)
			(lift_event false event#connect#button_press) in
	on button_press e -> button_gtk (GdkEvent.Button.button e)

let lift_scroll event =
	event#add [ `SCROLL ];
	on (filter_e
			(fun e -> GdkEvent.get_type e = `SCROLL)
			(lift_event false event#connect#any)) e ->
		direction_gtk (GdkEvent.Scroll.direction (GdkEvent.Scroll.cast e))

type modifier = [ `Shift | `Control | `Meta | `Caps | `Mod of int ]
let modifiers_gtk l =
	List.fold_left (fun l ->
		function
		| `CONTROL -> `Control :: l
		| `LOCK -> `Caps :: l
		| `MOD1 -> `Meta :: l
		| `MOD2 -> `Mod 2 :: l
		| `MOD3 -> `Mod 3 :: l
		| `MOD4 -> `Mod 4 :: l
		| `MOD5 -> `Mod 5 :: l
		| `SHIFT -> `Shift :: l
		| _ -> l) [] l

(* TODO: broken *)
let lift_modifiers event =
	(* also should use focus change? *)
	event#add [ `KEY_PRESS; `KEY_RELEASE ];
	hold []
		(on (merge_e [
				lift_event false event#connect#key_press;
				lift_event false event#connect#key_release ]) e ->
			modifiers_gtk (GdkEvent.Key.state e))

let lift_size ~d2c event =
	(* TODO: should this watch unmap or something? *)
	hold (d2c (0., 0.))
		(on (lift_event false event#connect#configure) e ->
			d2c (float (GdkEvent.Configure.width e),
				float (GdkEvent.Configure.height e)))

type key = [
	| `Char of char
	| `Numpad of char
	| `Function of int
	| `Escape | `Backspace | `Tab | `Enter | `Key of int ]

open GdkKeysyms

(* TODO: number pad *)
let keytrans =
	let tbl = Hashtbl.create 13 in
	List.iter (fun (k, (v: key)) -> Hashtbl.add tbl k v) [
		_BackSpace, `Backspace;
		_Tab, `Tab;
		_Return, `Enter;
		_Escape, `Escape;
		_F1, `Function 1;
		_F2, `Function 2;
		_F3, `Function 3;
		_F4, `Function 4;
		_F5, `Function 5;
		_F6, `Function 6;
		_F7, `Function 7;
		_F8, `Function 8;
		_F9, `Function 9;
		_F10, `Function 10;
		_F11, `Function 11;
		_F12, `Function 12;
	]; tbl

let lift_keypress widget event =
	let start r =
		event#add [ `KEY_PRESS ];
		widget#misc#set_can_focus true;
		[event#connect#key_press ~callback: (fun e ->
			let keyval = GdkEvent.Key.keyval e in
			let key =
				try Hashtbl.find keytrans keyval with Not_found ->
				if keyval >= 0x20 && keyval < 0x7F
				then `Char (char_of_int keyval)
				else `Key keyval
			in send_event r key; true);
		 event#connect#button_press ~callback: (fun _ ->
		 	widget#misc#grab_focus (); false)]
	and stop hl =
		widget#misc#set_can_focus false;
		List.iter (GtkSignal.disconnect widget#as_widget) hl in
	event_source start stop

type 'a input = <
	pointer: ('a * 'a) option behavior;
	buttons: button list behavior;
	click: button event;
	scroll: direction event;
	modifiers: modifier list behavior;
	keypress: key event;
	size: ('a * 'a) behavior;
>

let lift_input ~p2c ~d2c (widget: GObj.widget) (event: GObj.event_ops) =
	(* p2c and d2c are functions that should translate GTK integer points and distances (resp.)
	   into values considered by the canvas to be "device" coordinates
	   (i.e., the user should be able to pass these values directly to the canvas's
	   device_to_user functions at any time and receive the corresponding user-space values) *)
	object
		method pointer = lift_pointer ~p2c widget event
		method buttons = lift_buttons event
		method click = lift_click event
		method scroll = lift_scroll event
		method modifiers = lift_modifiers event
		method keypress = lift_keypress widget event
		method size = lift_size ~d2c event
	end
